home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / map.t < prev    next >
Text File  |  1988-05-02  |  10KB  |  270 lines
  1. (herald map (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (define (map! proc l)
  27.   (do ((z l (cdr z)))
  28.       ((null? z) l)
  29.     (set (car z) (proc (car z)))))
  30.  
  31. ;;; Horrible cons-intensive definition.  Fix later.  There should be an
  32. ;;;  APPLY-MAP.
  33.  
  34. (define (map proc l . lists)
  35.   (cond ((null? lists)
  36.          (map1 proc l))
  37.         (else
  38.          (do ((l l (cdr l))
  39.               (result '() (block0 (cons (apply proc (car l) (map1 car lists))
  40.                                         result)
  41.                                   (map! cdr lists))))
  42.              ((or (null-list? l)
  43.                   (any? null-list? lists))
  44.               (reverse! result))))))
  45.  
  46. (define (mapcdr proc l . lists)
  47.   (do ((l l (cdr l))
  48.        (result '() (block0 (cons (apply proc l lists) result)
  49.                            (map! cdr lists))))
  50.       ((or (null-list? l)
  51.            (any? null-list? lists))
  52.        (reverse! result))))
  53.  
  54. (define (walk proc l . lists)
  55.   (cond ((null? lists)
  56.          (walk1 proc l))
  57.         (else
  58.          (do ((l l (cdr l)))
  59.              ((or (null-list? l)
  60.                   (any? null-list? lists))
  61.               value-of-walk)
  62.            (apply proc (car l) (map1 car lists))
  63.            (map! cdr lists)))))
  64.  
  65. (define (walkcdr proc l . lists)
  66.   (do ((l l (cdr l)))
  67.       ((or (null-list? l)
  68.            (any? null-list? lists))
  69.        (undefined-value "value of WALKCDR"))
  70.     (apply proc l lists)
  71.     (map! cdr lists)))
  72.  
  73. (define (map-append proc l . lists)
  74.   (apply append (apply map proc l lists)))
  75.  
  76. (define (map-append! proc l . lists)
  77.   (apply append! (apply map proc l lists)))
  78.  
  79. ;;; Thanks to Jim Meehan for the multiple list arguments.
  80. ;;; FUNCTIONS:
  81. ;;; ----------
  82. ;;; (ANY?      pred . lists)
  83. ;;; (EVERY?    pred . lists)
  84. ;;; (ANYCDR?   pred . lists)
  85. ;;; (EVERYCDR? pred . lists)
  86. ;;; (ANY       pred . lists)
  87. ;;; (EVERY     pred . lists)
  88. ;;; (ANYCDR    pred . lists)
  89. ;;; (EVERYCDR  pred . lists)
  90.  
  91. ;;; test cases:
  92. ;;;
  93. ;;;     (any      pair? '())    => ()
  94. ;;;     (every    pair? '())    => t
  95. ;;;     (anycdr   pair? '())    => ()
  96. ;;;     (everycdr pair? '())    => ()
  97. ;;;
  98. ;;;     (any      pair? '(a))   => ()
  99. ;;;     (every    pair? '(a))   => ()
  100. ;;;     (anycdr   pair? '(a))   => t
  101. ;;;     (everycdr pair? '(a))   => ()
  102. ;;;
  103. ;;;     (any      pair? '((a))) => t
  104. ;;;     (every    pair? '((a))) => t
  105. ;;;     (anycdr   pair? '((a))) => t
  106. ;;;     (everycdr pair? '((a))) => ()
  107. ;;;
  108. ;;;     (any      null? '(() a)) => t
  109. ;;;     (every    null? '(() a)) => ()
  110. ;;;     (anycdr   null? '(() a)) => t
  111. ;;;     (everycdr null? '(() a)) => ()
  112. ;;;
  113. ;;;     (any      null? '())     => ()
  114. ;;;     (every    null? '())     => t
  115. ;;;     (anycdr   null? '())     => t
  116. ;;;     (everycdr null? '())     => t
  117.  
  118. ;;; care must be taken here not to involve map in any's definition, since
  119. ;;; map calls any.
  120.  
  121.  
  122. ;(define (any pred l)    
  123. ;  (iterate any ((l l))
  124. ;    (cond ((null-list? l) nil)
  125. ;          ((pred (car l)))
  126. ;          (else (any (cdr l))))))
  127.  
  128. (define (any pred . lists) 
  129.   (cond ((null? lists) (any-every-error 'ANY))
  130.         ((null? (cdr lists)) ;special case for 1 list (no consing)
  131.          (labels (((f l)
  132.                    (cond ((null-list? l) nil)
  133.                          ((pred (car l)))
  134.                          (else (f (cdr l))))))
  135.            (f (car lists))))
  136.         (else
  137.           (let ((xx lists)
  138.                 (yy (null-copy lists)))
  139.             (labels (((g x y)
  140.                       (cond ((null? x)
  141.                              (or (apply pred yy) (g xx yy)))
  142.                             ((null-list? (car x)) nil)
  143.                             (else (set (car y) (caar x))
  144.                                   (set (car x) (cdar x))
  145.                                   (g (cdr x) (cdr y))))))
  146.               (g xx yy))))))
  147.  
  148. ;(define (anycdr pred l)          
  149. ;  (iterate anycdr ((l l))
  150. ;    (cond ((atom? l) (pred l))            ; huh?
  151. ;          ((pred l))
  152. ;          (else (anycdr (cdr l))))))
  153.  
  154. (define (anycdr pred . lists)
  155.   (cond ((null? lists) (any-every-error 'ANYCDR))
  156.         ((null? (cdr lists))
  157.          (labels (((f l)
  158.                    (cond ((atom? l) (pred l))
  159.                          ((pred l))
  160.                          (else (f (cdr l))))))
  161.            (f (car lists))))
  162.         (else
  163.           (let ((xx lists)
  164.                 (yy (null-copy lists)))
  165.             (labels (((g x y v end?)
  166.                       (cond ((null? x)
  167.                              (cond ((apply pred yy))
  168.                                    (end? nil)
  169.                                    (else (g xx yy nil nil))))
  170.                             ((atom? (car x))
  171.                              (set (car y) (car x))
  172.                              (g (cdr x) (cdr y) v t))
  173.                             (else (set (car y) (car x))
  174.                                   (set (car x) (cdar x))
  175.                                   (g (cdr x) (cdr y) v end?)))))
  176.               (g xx yy nil nil))))))
  177.  
  178. ;(define (every pred l)              
  179. ;  (iterate every ((l l))
  180. ;    (cond ((null-list? l) t)
  181. ;          ((pred (car l)) => (lambda (x)
  182. ;                               (if (null? (cdr l)) x
  183. ;                                 (every (cdr l)))))
  184. ;          (else nil))))
  185.  
  186. (define (every pred . lists) 
  187.   (cond ((null? lists) (any-every-error 'EVERY))
  188.         ((null? (cdr lists))
  189.          (labels (((g v l) (cond ((null? v) nil)
  190.                                  ((null-list? l) v)
  191.                                  (else (g (pred (car l)) (cdr l))))))
  192.            (g t (car lists))))
  193.         (else
  194.           (let ((xx lists)
  195.                 (yy (null-copy lists)))
  196.             (labels (((outer x y v)
  197.                       (labels (((inner x y)
  198.                                 (cond ((null? x)
  199.                                        (let ((v (apply pred yy)))
  200.                                          (and v (outer xx yy v))))
  201.                                       ((null-list? (car x)) v)
  202.                                       (else (set (car y) (caar x))
  203.                                             (set (car x) (cdar x))
  204.                                             (inner (cdr x) (cdr y))))))
  205.                         (inner x y))))
  206.               (outer xx yy t))))))
  207.  
  208. ;(define (everycdr pred l)   
  209. ;  (iterate everycdr ((l l))
  210. ;    (cond ((atom? l) (pred l))            ; huh?
  211. ;          ((not (pred l)) nil)
  212. ;          (else (everycdr (cdr l))))))
  213.  
  214. (define (everycdr pred . lists)
  215.   (cond ((null? lists) (any-every-error 'EVERYCDR))
  216.         ((null? (cdr lists))
  217.          (labels (((f l)
  218.                    (cond ((atom? l) (pred l))
  219.                          ((not (pred l)) nil)
  220.                          (else (f (cdr l))))))
  221.            (f (car lists))))
  222.          (else 
  223.            (let ((xx lists)
  224.                  (yy (null-copy lists)))
  225.              (labels (((g x y end?)
  226.                        (cond ((null? x)
  227.                               (cond ((apply pred yy) =>
  228.                                      (lambda (v)
  229.                                        (if end? v 
  230.                                            (g xx yy nil))))
  231.                                     (else nil)))
  232.                              ((atom? (car x))
  233.                               (set (car y) (car x))
  234.                               (g (cdr x) (cdr y) t))
  235.                              (else (set (car y) (car x))
  236.                                    (set (car x) (cdar x))
  237.                                    (g (cdr x) (cdr y) end?)))))
  238.                (g xx yy nil))))))
  239.                                                         
  240. (define (any?      pred . l) (if (apply any      pred l) t nil))
  241. (define (anycdr?   pred . l) (if (apply anycdr   pred l) t nil))
  242. (define (every?    pred . l) (if (apply every    pred l) t nil))
  243. (define (everycdr? pred . l) (if (apply everycdr pred l) t nil))
  244.  
  245. ;(define-integrable any?      (compose true? any))
  246. ;(define-integrable anycdr?   (compose true? anycdr))
  247. ;(define-integrable every?    (compose true? every))
  248. ;(define-integrable everycdr? (compose true? everycdr))
  249.  
  250. (define (any-every-error name)
  251.   (error "~s must take at least 1 list." name))
  252.  
  253. (define (null-copy l)
  254.   (do ((x '() (cons nil x))
  255.        (l l (cdr l)))
  256.       ((null? l) x)))
  257.  
  258. ;;; Miscellany
  259.  
  260. (define (*and . x) (every identity x))
  261. (define (*or  . x) (any   identity x))
  262.  
  263. (define-integrable (*and? . x) (every? identity x))
  264. (define-integrable (*or?  . x) (any?   identity x))
  265.  
  266. ;(define-syntax (and? . x) `(if (and ,@x) t nil))
  267. ;(define-syntax (or?  . x) `(if (or  ,@x) t nil))
  268.  
  269. (define-integrable (*if pred con alt) (if pred con alt))
  270.